{- This file is part of funbot.
 -
 - Written in 2015, 2017 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE OverloadedStrings #-}

-- | GitLab web hook types and parser. Development of this module so far
-- specifically tracks the GitLab instance and version running at
-- <https://git.snowdrift.coop>. In addition, any prorietary EE features are
-- ignored, i.e. we assume GitLab CE.
module Web.Hook.GitLab
    ( CommitID
    , Url
    , File
    , Author (..)
    , User (..)
    , Commit (..)
    , Diff (..)
    , Snippet (..)
    , NoteTarget (..)
    , IssueState (..)
    , Issue (..)
    , IssueAction (..)
    , Project (..)
    , Label (..)
    , MergeRequest (..)
    , Note (..)
    , Push (..)
    , IssueEvent (..)
    , MergeRequestEvent (..)
    , NoteEvent (..)
    , Event (..)
    , parse
    )
where

import Control.Applicative
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Time.Calendar (Day)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (parseTimeM, defaultTimeLocale)

import qualified Data.ByteString.Lazy as B
import qualified Data.Text as T

import Web.Hook.Util

parseDateTime :: Monad m => String -> m UTCTime
parseDateTime = parseTimeM False defaultTimeLocale "%F %T %Z"

parseDate :: Monad m => String -> m Day
parseDate = parseTimeM False defaultTimeLocale "%F"

type CommitID = T.Text

type Url = T.Text

type File = T.Text

data Author = Author
    { authorName  :: T.Text
    -- , authorEmail :: T.Text
    }
    deriving Show

instance FromJSON Author where
    parseJSON (Object o) =
        Author
        <$> o .: "name"
        -- <*> o .: "email"
    parseJSON v          = typeMismatch "Author" v

data User = User
    { userName     :: T.Text
    -- , userUsername :: T.Text
    -- , userAvatar   :: Url
    }
    deriving Show

instance FromJSON User where
    parseJSON (Object o) =
        User
        <$> o .: "name"
        -- <*> o .: "username"
        -- <*> o .: "avatar_url"
    parseJSON v          = typeMismatch "User" v

data Commit = Commit
    { commitId        :: CommitID
    , commitMessage   :: T.Text
    -- , commitTimestamp :: T.Text
    , commitUrl       :: Url
    , commitAuthor    :: Author
    -- , commitAdded     :: [File]
    -- , commitModified  :: [File]
    -- , commitRemoved   :: [File]
    }
    deriving Show

instance FromJSON Commit where
    parseJSON (Object o) =
        Commit
        <$> o .:  "id"
        <*> o .:  "message"
        -- <*> o .:  "timestamp"
        <*> o .:  "url"
        <*> o .:  "author"
        -- <*> o .:? "added"    .!= []
        -- <*> o .:? "modified" .!= []
        -- <*> o .:? "removed"  .!= []
    parseJSON v          = typeMismatch "Commit" v

data IssueState = ISOpen deriving Show

instance FromJSON IssueState where
    parseJSON v =
        let p = parseJSON v
        in  ISOpen <$ text p "opened"

data Issue = Issue
    { -- issueInternalId       :: Int
      issueTitle            :: T.Text
    -- , issueAssigneeId       :: Maybe Int
    -- , issueAuthorId         :: Int
    -- , issueProjectId        :: Int
    -- , issueCreatedAt        :: UTCTime
    -- , issueUpdatedAt        :: UTCTime
    -- , issuePosition         :: Int
    -- , issueBranch           :: Maybe T.Text
    -- , issueDescription      :: T.Text
    -- , issueMilestoneId      :: Maybe Int
    -- , issueState            :: IssueState
    , issueId               :: Int
    -- , issueUpdatedById      :: Maybe Int
    -- , issueMovedToId        :: Maybe Int
    -- , issueConfidential     :: Bool
    -- , issueDeletedAt        :: Maybe UTCTime
    -- , issueDueDate          :: Maybe Day
    -- , issueLockVersion      :: Maybe Int
    -- , issueTimeEstimate     :: Int
    -- , issueRelativePosition :: Int
    -- , issueClosedAt         :: Maybe UTCTime
    -- , issueLastEditedAt     :: Maybe UTCTime
    -- , issueLastEditedById   :: Maybe Int
    , issueUrl              :: Url
    }
    deriving Show

instance FromJSON Issue where
    parseJSON (Object o) =
        Issue
        -- <$> o .: "id"
        <$> o .: "title"
        -- <*> o .: "assignee_id"
        -- <*> o .: "author_id"
        -- <*> o .: "project_id"
        -- <*> (o .: "created_at" >>= parseDateTime)
        -- <*> (o .: "updated_at" >>= parseDateTime)
        -- <*> o .: "position"
        -- <*> o .: "branch_name"
        -- <*> o .: "description"
        -- <*> o .: "milestone_id"
        -- <*> o .: "state"
        <*> o .: "iid"
        -- <*> o .: "updated_by_id"
        -- <*> o .: "moved_to_id"
        -- <*> o .: "confidential"
        -- <*> (o .: "deleted_at" >>= traverse parseDateTime)
        -- <*> (o .: "due_date" >>= traverse parseDate)
        -- <*> o .: "lock_version"
        -- <*> o .: "time_estimate"
        -- <*> o .: "relative_position"
        -- <*> (o .: "closed_at" >>= traverse parseDateTime)
        -- <*> (o .: "last_edited_at" >>= traverse parseDateTime)
        -- <*> o .: "last_edited_by_id"
        <*> o .:? "url" .!= T.empty
    parseJSON v          = typeMismatch "Issue" v

data IssueAction = IssueOpen | IssueUpdate | IssueClose deriving Show

instance FromJSON IssueAction where
    parseJSON v =
        let p = parseJSON v
        in  IssueOpen   <$ text p "open"   <|>
            IssueUpdate <$ text p "update" <|>
            IssueClose  <$ text p "close"  <|>
            fail "Unrecognized issue action"

data Project = Project
    { projectName              :: T.Text
    -- , projectDescription       :: T.Text
    , projectWebUrl            :: Url
    -- , projectAvatarUrl         :: Maybe Url
    -- , projectGitSshUrl         :: Url
    -- , projectGitHttpUrl        :: Url
    -- , projectNamespace         :: T.Text
    -- , projectVisibilityLevel   :: Int
    -- , projectPathWithNamespace :: T.Text
    -- , projectDefaultBranch     :: T.Text
    }
    deriving Show

instance FromJSON Project where
    parseJSON (Object o) =
        Project
        <$> o .: "name"
        -- <*> o .: "description"
        <*> o .: "web_url"
        -- <*> o .: "avatar_url"
        -- <*> o .: "git_ssh_url"
        -- <*> o .: "git_http_url"
        -- <*> o .: "namespace"
        -- <*> o .: "visibility_level"
        -- <*> o .: "path_with_namespace"
        -- <*> o .: "default_branch"
    parseJSON v          = typeMismatch "Project" v

data Label = Label
    { -- labelId          :: Int
    -- , labelTitle       :: T.Text
    -- , labelColor       :: T.Text
    -- , labelProjectId   :: Int
    -- , labelCreatedAt   :: UTCTime
    -- , labelUpdatedAt   :: UTCTime
    -- , labelTemplate    :: Bool
    -- , labelDescription :: T.Text
    -- , labelType        :: T.Text
    -- , labelGroupId     :: Maybe Int
    }
    deriving Show

instance FromJSON Label where
    parseJSON (Object o) =
        pure Label
        -- <$> o .: "id"
        -- <*> o .: "title"
        -- <*> o .: "color"
        -- <*> o .: "project_id"
        -- <*> (o .: "created_at" >>= parseDateTime)
        -- <*> (o .: "updated_at" >>= parseDateTime)
        -- <*> o .: "template"
        -- <*> o .: "description" .!= T.empty
        -- <*> o .: "type"
        -- <*> o .: "group_id"
    parseJSON v          = typeMismatch "Label" v

data MergeRequest = MergeRequest
    { -- mrInternalId      :: Int
    -- , mrTargetBranch    :: T.Text
    -- , mrSourceBranch    :: T.Text
    -- , mrSourceProjectId :: Int
    -- , mrAuthorId        :: Int
    -- , mrAssigneeId      :: Maybe Int
      mrTitle           :: T.Text
    -- , mrCreatedAt       :: T.Text
    -- , mrUpdatedAt       :: T.Text
    -- , mrStCommits       :: ?
    -- , mrStDiffs         :: ?
    -- , mrMilestoneId     :: Maybe Int
    -- , mrState           :: T.Text
    -- , mrMergeStatus     :: T.Text
    -- , mrTargetProjectId :: Int
    , mrId              :: Int
    -- , mrDescription     :: T.Text
    -- , mrSource          :: Project
    , mrTarget          :: Project
    -- , mrLastCommit      :: Commit
    -- , mrWorkInProgress  :: Bool
    , mrUrl             :: Url
    }
    deriving Show

instance FromJSON MergeRequest where
    parseJSON (Object o) =
        MergeRequest
        -- <$> o .: "id"
        -- <*> o .: "target_branch"
        -- <*> o .: "source_branch"
        -- <*> o .: "source_project_id"
        -- <*> o .: "author_id"
        -- <*> o .: "assignee_id"
        <$> o .: "title"
        -- <*> o .: "created_at"
        -- <*> o .: "updated_at"
        -- <*> o .: "st_commits"
        -- <*> o .: "st_diffs"
        -- <*> o .: "milestone_id"
        -- <*> o .: "state"
        -- <*> o .: "merge_status"
        -- <*> o .: "target_project_id"
        <*> o .: "iid"
        -- <*> o .: "description"
        -- <*> o .: "source"
        <*> o .: "target"
        -- <*> o .: "last_commit"
        -- <*> o .: "work_in_progress"
        <*> o .:? "url" .!= T.empty
    parseJSON v          = typeMismatch "MergeRequest" v

data Diff = Diff
    { -- diffDiff        :: T.Text
    -- , diffNewPath     :: T.Text
    -- , diffOldPath     :: T.Text
    -- , diffAMode       :: T.Text
    -- , diffBMode       :: T.Text
    -- , diffNewFile     :: Bool
    -- , diffRenamedFile :: Bool
    -- , diffDeletedFile :: Bool
    }
    deriving Show

instance FromJSON Diff where
    parseJSON (Object o) =
        pure Diff
        -- <$> o .: "diff"
        -- <*> o .: "new_path"
        -- <*> o .: "old_path"
        -- <*> o .: "a_mode"
        -- <*> o .: "b_mode"
        -- <*> o .: "new_file"
        -- <*> o .: "renamed_file"
        -- <*> o .: "deleted_file"
    parseJSON v          = typeMismatch "Diff" v

data Note = Note
    { -- noteId         :: Int
      noteNote       :: T.Text
    -- , noteType       :: NoteableType
    -- , noteAuthorId   :: Int
    -- , noteCreatedAt  :: T.Text
    -- , noteUpdatedAt  :: T.Text
    -- , noteProjectId  :: Int
    -- , noteAttachment :: Maybe ()
    -- , noteLineCode   :: Maybe T.Text
    -- , noteCommitId   :: CommitID
    -- , noteNoteableId :: Maybe Int
    -- , noteSystem     :: Bool
    -- , noteStDiff     :: Maybe Diff
    , noteUrl        :: Url
    }
    deriving Show

instance FromJSON Note where
    parseJSON (Object o) =
        Note
        -- <*> o .: "id"
        <$> o .: "note"
        -- <*> o .: "noteable_type"
        -- <*> o .: "author_id"
        -- <*> o .: "created_at"
        -- <*> o .: "updated_at"
        -- <*> o .: "project_id"
        -- <*> o .: "attachment"
        -- <*> o .: "line_code"
        -- <*> o .: "commit_id"
        -- <*> o .: "noteable_id"
        -- <*> o .: "system"
        -- <*> o .: "st_diff"
        <*> o .: "url"
    parseJSON v          = typeMismatch "Note" v

data Push = Push
    { -- pushBefore       :: CommitID
    -- , pushAfter        :: CommitID
      pushRef          :: T.Text
    -- , pushUserId       :: Int
    , pushUserName     :: T.Text
    -- , pushUserEmail    :: T.Text
    -- , pushProjectId    :: Int
    , pushProject      :: Project
    , pushCommits      :: [Commit]
    -- , pushCommitsTotal :: Int
    }
    deriving Show

instance FromJSON Push where
    parseJSON (Object o) =
        Push
        -- <$> o .: "before"
        -- <*> o .: "after"
        <$> o .: "ref"
        -- <*> o .: "user_id"
        <*> o .: "user_name"
        -- <*> o .: "user_email"
        -- <*> o .: "project_id"
        <*> o .: "project"
        <*> o .: "commits"
        -- <*> o .: "total_commits_count"
    parseJSON v          = typeMismatch "Push" v

data IssueEvent = IssueEvent
    { ieUser      :: User
    , ieProject   :: Project
    , ieIssue     :: Issue
    , ieAssignees :: [User]
    , ieLabels    :: [Label]
    , ieAction    :: IssueAction
    }
    deriving Show

instance FromJSON IssueEvent where
    parseJSON (Object o) = do
        user <- o .: "user"
        project <- o .: "project"
        assignees <- o .:? "assignees" .!= []
        labels <- o .: "labels"
        attrs <- o .: "object_attributes"
        issue <- o .: "object_attributes"
        action <- attrs .: "action"
        return $ IssueEvent user project issue assignees labels action
    parseJSON v          = typeMismatch "IssueEvent" v

data MergeRequestEvent = MergeRequestEvent
    { mreUser    :: User
    , mreRequest :: MergeRequest
    , mreAction  :: T.Text
    }
    deriving Show

instance FromJSON MergeRequestEvent where
    parseJSON (Object o) = do
        user <- o .: "user"
        attrs <- o .: "object_attributes"
        mr <- o .: "object_attributes"
        action <- attrs .: "action"
        return $ MergeRequestEvent user mr action
    parseJSON v          = typeMismatch "MergeRequestEvent" v

data Snippet = Snippet
    { snippetId         :: Int
    -- , snippetTitle      :: T.Text
    -- , snippetContent    :: T.Text
    -- , snippetAuthorId   :: Int
    -- , snippetProjectId  :: Int
    -- , snippetCreatedAt  :: T.Text
    -- , snippetUpdatedAt  :: T.Text
    -- , snippetFileName   :: T.Text
    -- , snippetExpiresAt  :: Maybe T.Text
    -- , snippetType       :: T.Text
    -- , snippetVisibility :: Int
    }
    deriving Show

instance FromJSON Snippet where
    parseJSON (Object o) =
        Snippet
        <$> o .: "id"
        -- <*> o .: "title"
        -- <*> o .: "content"
        -- <*> o .: "author_id"
        -- <*> o .: "project_id"
        -- <*> o .: "created_at"
        -- <*> o .: "updated_at"
        -- <*> o .: "file_name"
        -- <*> o .: "expires_at"
        -- <*> o .: "type"
        -- <*> o .: "visibility_level"
    parseJSON v          = typeMismatch "Snippet" v

data NoteTarget
    = NTCommit Commit
    | NTIssue Issue
    | NTMergeRequest MergeRequest
    | NTSnippet Snippet
    deriving Show

data NoteEvent = NoteEvent
    { neUser      :: User
    , neProjectId :: Int
    , neProject   :: Project
    , neNote      :: Note
    , neTarget    :: NoteTarget
    }
    deriving Show

instance FromJSON NoteEvent where
    parseJSON (Object o) =
        NoteEvent <$>
        o .: "user" <*>
        o .: "project_id" <*>
        o .: "project" <*>
        o .: "object_attributes" <*>
        ( NTCommit       <$> o .: "commit"        <|>
          NTMergeRequest <$> o .: "merge_request" <|>
          NTIssue        <$> o .: "issue"         <|>
          NTSnippet      <$> o .: "snippet"       <|>
          fail "Unrecognized note target"
        )
    parseJSON v          = typeMismatch "NoteEvent" v

data PipelineEvent = PipelineEvent
    { -- plePipeline :: Pipeline
    -- , pleUser     :: User
    -- , pleProject  :: Project
    -- , pleCommit   :: Commit
    -- , pleBuilds   :: [Build]
    }
    deriving Show

instance FromJSON PipelineEvent where
    parseJSON (Object o) =
        pure PipelineEvent
        -- <$> o .: "pipeline"
        -- <*> o .: "user"
        -- <*> o .: "project"
        -- <*> o .: "commit"
        -- <*> o .: "builds"
    parseJSON v          = typeMismatch "PipelineEvent" v

data Event
    = EventPush Push
    | EventPushTag Push
    | EventIssue IssueEvent
    | EventMergeRequest MergeRequestEvent
    | EventNote NoteEvent
    | EventPipeline PipelineEvent
    deriving Show

instance FromJSON Event where
    parseJSON v@(Object o) =
        let kind = text $ o .: "object_kind"
        in  kind "push"          *> (EventPush         <$> parseJSON v) <|>
            kind "tag_push"      *> (EventPushTag      <$> parseJSON v) <|>
            kind "issue"         *> (EventIssue        <$> parseJSON v) <|>
            kind "merge_request" *> (EventMergeRequest <$> parseJSON v) <|>
            kind "note"          *> (EventNote         <$> parseJSON v) <|>
            kind "pipeline"      *> (EventPipeline     <$> parseJSON v) <|>
            fail "Unrecognized event type"
    parseJSON v            = typeMismatch "Event" v

-- | Parse a JSON string (the body of the HTTP request) into event information.
-- If parsing fails, return 'Left' an error message.
parse :: B.ByteString -> Either String Event
parse = eitherDecode
